home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol058 / alphamar.bas (.txt) next >
Encoding:
GW-BASIC  |  1987-01-13  |  4.5 KB  |  152 lines
  1. 100  TITLE$ = "Alphabetic List of Marriages"
  2. 105  TITLE$ = TITLE$ + " ON DISPLAY"
  3. 110  VERSION$ = "Version 1.3"
  4. 115  COPY1$ = "Copyright (c) 1983, by:"
  5. 120  COPY2$ = "Melvin O. Duke"
  6. 125  PRICE$ = "$35"
  7. 130  ADDR1$ = "Melvin O. Duke"
  8. 135  ADDR2$ = "P. O. Box 20836"
  9. 140  ADDR3$ = "San Jose, CA  95160"
  10. 145  REM Dimension Statements go here
  11. 150  DIM PERS.ID(400), MARR.ID(400), IDX$(400)
  12. 170  REM Produce the first screen
  13. 175  KEY OFF : CLS
  14. 180  REM Draw the outer double box
  15. 185  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 400
  16. 190  REM Find the title location
  17. 195  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  18. 200  REM Draw the title box
  19. 205  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 600
  20. 210  REM Print the title
  21. 215  LOCATE 4,TITLE.POS : PRINT TITLE$
  22. 220  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  23. 225  REM Draw the Contribution box
  24. 230  R1 = 8 : C1 = 19 : R2 = 17 : C2 = 62 : GOSUB 400
  25. 235  REM Request the Contribution
  26. 240  LOCATE 9,23 : PRINT "If you are using these programs, and"
  27. 245  LOCATE 10,21 : PRINT "finding them of value, your contribution"
  28. 250  LOCATE 11,23 : PRINT "("+PRICE$+" suggested) will be appreciated."
  29. 255  REM Draw the Mailing Label
  30. 260  R1 = 12 : C1 = 28 : R2 = 16 : C2 = 52 : GOSUB 600
  31. 265  REM Print the Name and Address
  32. 270  LOCATE 13,40-INT(LEN(ADDR1$)/2) :  PRINT ADDR1$;
  33. 275  LOCATE 14,40-INT(LEN(ADDR2$)/2) :  PRINT ADDR2$;
  34. 280  LOCATE 15,40-INT(LEN(ADDR3$)/2) :  PRINT ADDR3$;
  35. 285  REM Draw the Copyright box
  36. 290  R1 = 19 : C1 = 27 : R2 = 22 : C2 = 53 : GOSUB 400
  37. 295  REM Print the Copyright
  38. 300  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  39. 305  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  40. 310  GOTO 740
  41. 400  REM subroutine to print a double box
  42. 410  FOR I = R1 + 1 TO R2 - 1
  43. 420   LOCATE I, C1 : PRINT CHR$(186);
  44. 430   LOCATE I, C2 : PRINT CHR$(186);
  45. 440  NEXT I
  46. 450  FOR J = C1 + 1 TO C2 - 1
  47. 460   LOCATE R1, J : PRINT CHR$(205);
  48. 470   LOCATE R2, J : PRINT CHR$(205);
  49. 480  NEXT J
  50. 490   LOCATE R1, C1 : PRINT CHR$(201);
  51. 500   LOCATE R1, C2 : PRINT CHR$(187);
  52. 510   LOCATE R2, C1 : PRINT CHR$(200);
  53. 520   LOCATE R2, C2 : PRINT CHR$(188);
  54. 530  RETURN
  55. 600  REM subroutine to print a single box
  56. 610  FOR I = R1 + 1 TO R2 - 1
  57. 620   LOCATE I, C1 : PRINT CHR$(179);
  58. 630   LOCATE I, C2 : PRINT CHR$(179);
  59. 640  NEXT I
  60. 650  FOR J = C1 + 1 TO C2 - 1
  61. 660   LOCATE R1, J : PRINT CHR$(196);
  62. 670   LOCATE R2, J : PRINT CHR$(196);
  63. 680  NEXT J
  64. 690   LOCATE R1, C1 : PRINT CHR$(218);
  65. 700   LOCATE R1, C2 : PRINT CHR$(191);
  66. 710   LOCATE R2, C1 : PRINT CHR$(192);
  67. 720   LOCATE R2, C2 : PRINT CHR$(217);
  68. 730  RETURN
  69. 740  REM ask user to press a key to continue
  70. 750  LOCATE 25,1
  71. 760  PRINT "Press any key to continue";
  72. 770  K$ = INKEY$ : IF K$ = "" THEN 770
  73. 780  CLS
  74. 1000  REM Alphabetic List of Marriages.
  75. 1010  REM By:  Melvin O. Duke.  Updated 26 June, 1983.
  76. 1020  OPEN "a:persfile" AS #1 LEN = 256
  77. 1030  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  78. 1040  REM Read the Marriage Index and then the Person File
  79. 1050  CLS
  80. 1060  OPEN "a:mindex" FOR INPUT AS #2
  81. 1070  INPUT #2, C
  82. 1080  LOCATE 19,1 : PRINT "There are:";C;"Marriage Index Records"
  83. 1090  FOR I = 1 TO C
  84. 1100   INPUT #2, PERS.ID(I), MARR.ID(I)
  85. 1110   LOCATE 23,1 : PRINT "Processing Marriage Index Record:";I,"Freespace";FRE(0)
  86. 1120   REM get the personal information
  87. 1130   GET #1, PERS.ID(I)
  88. 1140   REM Extract information from the file for use
  89. 1150   T2$ = F2$
  90. 1160   FOR J = 1 TO LEN(F2$) -1
  91. 1170    IF RIGHT$(T2$,1)=" " THEN T2$=LEFT$(T2$,LEN(T2$)-1) ELSE J=LEN(F2$)-1
  92. 1180   NEXT J
  93. 1190   T3$ = F3$
  94. 1200   FOR J = 1 TO LEN(F3$) -1
  95. 1210    IF RIGHT$(T3$,1)=" " THEN T3$=LEFT$(T3$,LEN(T3$)-1) ELSE J=LEN(F3$)-1
  96. 1220   NEXT J
  97. 1230   IDX$(I) = T2$+T3$
  98. 1240  NEXT I
  99. 1250  LOCATE 23,1 : PRINT SPACE$(79)
  100. 1260  REM Sort the index into ascending sequence
  101. 1270  REM
  102. 1280  FOR I = 1 TO 6
  103. 1290   B(I) = B(I-1)*4+1
  104. 1300   IF B(I) <= C/2 THEN K1 = I
  105. 1310  NEXT I
  106. 1320  B(K1) = INT(C/5)+1
  107. 1330  B(1) = 1
  108. 1340  FOR I = K1 TO 1 STEP -1
  109. 1350  LOCATE 23,1 : PRINT "Sorting Group:";I
  110. 1360   K1 = B(I)
  111. 1370   FOR J = K1 TO C
  112. 1380    LOCATE 23,20 : PRINT "J:";J;
  113. 1390    K2$ = IDX$(J) : TEMP1 = PERS.ID(J) : TEMP2 = MARR.ID(J)
  114. 1400    FOR K = J-K1 TO 0 STEP -K1
  115. 1410     LOCATE 23,30 : PRINT "K:";K, "Freespace:";FRE(0)
  116. 1420     IF K2$ > IDX$(K) THEN 1450
  117. 1430     IDX$(K+K1)=IDX$(K): PERS.ID(K+K1)=PERS.ID(K): MARR.ID(K+K1)=MARR.ID(K)
  118. 1440    NEXT K
  119. 1450    IDX$(K+K1)=K2$: PERS.ID(K+K1)=TEMP1: MARR.ID(K+K1)=TEMP2
  120. 1460   NEXT J
  121. 1470  NEXT I
  122. 1480  LOCATE 21,1 : PRINT "Printing the Alphabetical List"
  123. 1490  GOSUB 1510
  124. 1500  GOTO 1560
  125. 1510  LPRINT "   Alphabetic Listing of the Marriages File   ";DATE$;"   ";TIME$
  126. 1520  LPRINT
  127. 1530  LPRINT "  REC         SURNAME             GIVEN-NAMES"
  128. 1540  LPRINT "  ---         ---------------     ---------------------------"
  129. 1550  RETURN
  130. 1560  REM Read all records, and print the actual ones
  131. 1570  K = 0
  132. 1580  LOCATE 23,1 : PRINT SPACE$(79)
  133. 1590  FOR I = 1 TO C
  134. 1600   GET #1, ABS(PERS.ID(I))
  135. 1610   LOCATE 23,1 : PRINT "Printing Record:"; I, "Freespace:";FRE(0)
  136. 1620   REM Print the information in Alphabetical Order.
  137. 1630   T1 = CVS(F1$)
  138. 1640   IF T1 < 1 THEN 1710
  139. 1650   K = K + 1
  140. 1660   T2$ = F2$
  141. 1670   T3$ = F3$
  142. 1680   LPRINT USING "#####";MARR.ID(I);
  143. 1690   LPRINT TAB(15); T2$; T3$
  144. 1700   IF K MOD 55 = 0 THEN LPRINT CHR$(12);: GOSUB 1510
  145. 1710  NEXT I
  146. 1720  CLOSE #1
  147. 1730  CLOSE #2
  148. 1740  CLS : LOCATE 21,1
  149. 1750  PRINT "End of Program
  150. 1760  LPRINT CHR$(12);
  151. 1770  END
  152.